home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / clx_tar.z / clx_tar / clx / debug / event-test.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1990-05-01  |  7.0 KB  |  238 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*-
  2.  
  3. (in-package :xtest :use '(:xlib :lisp))
  4.  
  5. (defstruct event
  6.   key                       ; Event key
  7.   display                   ; Display event was reported to
  8.   ;; The following are from the CLX event
  9.   code
  10.   state
  11.   time
  12.   event-window
  13.   root
  14.   drawable
  15.   window
  16.   child
  17.   parent
  18.   root-x
  19.   root-y
  20.   x
  21.   y
  22.   width
  23.   height
  24.   border-width
  25.   override-redirect-p
  26.   same-screen-p
  27.   configure-p
  28.   hint-p
  29.   kind
  30.   mode
  31.   keymap
  32.   focus-p
  33.   count
  34.   major
  35.   minor
  36.   above-sibling
  37.   place
  38.   atom
  39.   selection
  40.   requestor
  41.   target
  42.   property
  43.   colormap
  44.   new-p
  45.   installed-p
  46.   format
  47.   type
  48.   data
  49.   send-event-p
  50.   )
  51.  
  52. (defun process-input (display &optional timeout)
  53.   "Process one event"
  54.   (declare (type display display)        ; The display (from initialize-clue)
  55.        (type (or null number) timeout)    ; optional timeout in seconds
  56.        (values (or null character)))        ; Returns NIL only if timeout exceeded
  57.   (let ((event (make-event)))
  58.     (setf (event-display event) display)
  59.     (macrolet ((set-event (&rest parameters)
  60.          `(progn ,@(mapcar #'(lambda (parm)
  61.                        `(setf (,(intern (concatenate 'string
  62.                               (string 'event-)
  63.                               (string parm)))
  64.                            event) ,parm))
  65.                    parameters)))
  66.            (dispatch (contact)
  67.           `(dispatch-event event event-key send-event-p ,contact)))
  68.  
  69.       (let ((result
  70.           (xlib:event-case (display :timeout timeout :force-output-p t)
  71.         ((:key-press :key-release :button-press :button-release)
  72.          (code time root window child root-x root-y x y
  73.                state same-screen-p event-key send-event-p)
  74.          (set-event code time root window child root-x root-y x y
  75.                 state same-screen-p)
  76.          (dispatch window))
  77.         
  78.         (:motion-notify
  79.           (hint-p time root window child root-x root-y x y
  80.               state same-screen-p event-key send-event-p)
  81.           (set-event hint-p time root window child root-x root-y x y
  82.                  state same-screen-p)
  83.           (dispatch window))
  84.         
  85.         ((:enter-notify :leave-notify)
  86.          (kind time root window child root-x root-y x y
  87.                state mode focus-p same-screen-p event-key send-event-p)
  88.          (set-event kind time root window child root-x root-y x y
  89.                 state mode focus-p same-screen-p)
  90.          (dispatch window))
  91.         
  92.         ((:focus-in :focus-out)
  93.          (kind window mode event-key send-event-p)
  94.          (set-event kind window mode)
  95.          (dispatch window))
  96.         
  97.         (:keymap-notify
  98.           (window keymap event-key send-event-p)
  99.           (set-event window keymap)
  100.           (dispatch window))
  101.         
  102.         (:exposure
  103.           (window x y width height count event-key send-event-p)
  104.           (set-event window x y width height count)
  105.           (dispatch window))
  106.         
  107.         (:graphics-exposure
  108.           (drawable x y width height count major minor event-key send-event-p)
  109.           (set-event drawable x y width height count major minor)
  110.           (dispatch drawable))
  111.         
  112.         (:no-exposure
  113.           (drawable major minor event-key send-event-p)
  114.           (set-event drawable major minor)
  115.           (dispatch drawable))
  116.         
  117.         (:visibility-notify
  118.           (window state event-key send-event-p)
  119.           (set-event window state)
  120.           (dispatch window))
  121.         
  122.         (:create-notify
  123.           (parent window x y width height border-width
  124.               override-redirect-p event-key send-event-p)
  125.           (set-event parent window x y width height border-width
  126.                  override-redirect-p)
  127.           (dispatch parent))
  128.         
  129.         (:destroy-notify
  130.           (event-window window event-key send-event-p)
  131.           (set-event event-window window)
  132.           (dispatch event-window))
  133.         
  134.         (:unmap-notify
  135.           (event-window window configure-p event-key send-event-p)
  136.           (set-event event-window window configure-p)
  137.           (dispatch event-window))
  138.         
  139.         (:map-notify
  140.           (event-window window override-redirect-p event-key send-event-p)
  141.           (set-event event-window window override-redirect-p)
  142.           (dispatch event-window))
  143.         
  144.         (:map-request
  145.           (parent window event-key send-event-p)
  146.           (set-event parent window)
  147.           (dispatch parent))
  148.         
  149.         (:reparent-notify
  150.           (event-window window parent x y override-redirect-p event-key send-event-p)
  151.           (set-event event-window window parent x y override-redirect-p)
  152.           (dispatch event-window))
  153.         
  154.         (:configure-notify
  155.           (event-window window above-sibling x y width height border-width
  156.                 override-redirect-p event-key send-event-p)
  157.           (set-event event-window window above-sibling x y width height
  158.                  border-width override-redirect-p)
  159.           (dispatch event-window))
  160.         
  161.         (:configure-request
  162.           (parent window above-sibling x y width height border-width event-key send-event-p)
  163.           (set-event parent window above-sibling x y width height border-width)
  164.           (dispatch parent))
  165.         
  166.         (:gravity-notify
  167.           (event-window window x y event-key send-event-p)
  168.           (set-event event-window window x y)
  169.           (dispatch event-window))
  170.         
  171.         (:resize-request
  172.           (window width height event-key send-event-p)
  173.           (set-event window width height)
  174.           (dispatch window))
  175.         
  176.         (:circulate-notify
  177.           (event-window window parent place event-key send-event-p)
  178.           (set-event event-window window parent place)
  179.           (dispatch event-window))
  180.         
  181.         (:circulate-request
  182.           (parent window place event-key send-event-p)
  183.           (set-event parent window place)
  184.           (dispatch parent))
  185.         
  186.         (:property-notify
  187.           (window atom time state event-key send-event-p)
  188.           (set-event window atom time state)
  189.           (dispatch window))
  190.         
  191.         (:selection-clear
  192.           (time window selection event-key send-event-p)
  193.           (set-event time window selection)
  194.           (dispatch window))
  195.         
  196.         (:selection-request
  197.           (time window requestor selection target property event-key send-event-p)
  198.           (set-event time window requestor selection target property)
  199.           (dispatch window))
  200.         
  201.         (:selection-notify
  202.           (time window selection target property event-key send-event-p)
  203.           (set-event time window selection target property)
  204.           (dispatch window))
  205.         
  206.         (:colormap-notify
  207.           (window colormap new-p installed-p event-key send-event-p)
  208.           (set-event window colormap new-p installed-p)
  209.           (dispatch window))
  210.         
  211.         (:client-message
  212.           (format window type data event-key send-event-p)
  213.           (set-event format window type data)
  214.           (dispatch window))
  215.         
  216.         (:mapping-notify
  217.           (request start count)
  218.           (mapping-notify display request start count)) ;; Special case
  219.         )))
  220.     (and result t)))))
  221.  
  222. (defun event-case-test (display)
  223.   ;; Tests universality of display, event-key, event-code, send-event-p and event-window
  224.   (event-case (display)
  225.     ((key-press key-release button-press button-release motion-notify
  226.       enter-notify leave-notify focus-in focus-out keymap-notify
  227.       exposure graphics-exposure no-exposure visibility-notify
  228.       create-notify destroy-notify unmap-notify map-notify map-request
  229.       reparent-notify configure-notify gravity-notify resize-request
  230.       configure-request circulate-notify circulate-request property-notify
  231.       selection-clear selection-request selection-notify colormap-notify client-message)
  232.      (display event-key event-code send-event-p event-window)
  233.      (print (list display event-key event-code send-event-p event-window)))
  234.     (mapping-notify ;; mapping-notify doesn't have event-window
  235.       (display event-key event-code send-event-p)
  236.       (print (list display event-key event-code send-event-p)))
  237.     ))
  238.